home *** CD-ROM | disk | FTP | other *** search
/ Clickx 115 / Clickx 115.iso / software / tools / windows / tails-i386-0.16.iso / live / filesystem.squashfs / usr / share / uim / i18n.scm < prev    next >
Encoding:
Text File  |  2010-11-07  |  7.6 KB  |  244 lines
  1. ;;; i18n.scm: Internationalization functions for uim
  2. ;;;
  3. ;;; Copyright (c) 2003-2009 uim Project http://code.google.com/p/uim/
  4. ;;;
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Redistribution and use in source and binary forms, with or without
  8. ;;; modification, are permitted provided that the following conditions
  9. ;;; are met:
  10. ;;; 1. Redistributions of source code must retain the above copyright
  11. ;;;    notice, this list of conditions and the following disclaimer.
  12. ;;; 2. Redistributions in binary form must reproduce the above copyright
  13. ;;;    notice, this list of conditions and the following disclaimer in the
  14. ;;;    documentation and/or other materials provided with the distribution.
  15. ;;; 3. Neither the name of authors nor the names of its contributors
  16. ;;;    may be used to endorse or promote products derived from this software
  17. ;;;    without specific prior written permission.
  18. ;;;
  19. ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS IS'' AND
  20. ;;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
  21. ;;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  22. ;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE
  23. ;;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  24. ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
  25. ;;; OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
  26. ;;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
  27. ;;; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
  28. ;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
  29. ;;; SUCH DAMAGE.
  30. ;;;;
  31.  
  32. (require "util.scm")
  33.  
  34. ;;
  35. ;; string translation
  36. ;;
  37.  
  38. ;; WARNING: ugettext and _ should not be used for normal codes.
  39. ;; convenience shorthand of runtime translation
  40. (define ugettext
  41.   (if (provided? "nls")
  42.       (lambda (str)
  43.     (dgettext (gettext-package) str))
  44.       (lambda (str)
  45.     str)))
  46.  
  47. ;; WARNING: ugettext and _ should not be used for normal codes.
  48. ;; shorthand version of gettext. it is also used as xgettext keyword
  49. (define _ ugettext)
  50.  
  51. ;; shorthand version of gettext_noop. it is used as xgettext keyword
  52. (define N_
  53.   (lambda (str)
  54.     str))
  55.  
  56. ;; All other gettext functions are defined in C. See uim/intl.c
  57.  
  58.  
  59. ;;
  60. ;; locale
  61. ;;
  62. (define-record 'locale
  63.   '((lang       "")
  64.     (territory  "")
  65.     (codeset    "")))
  66. (define locale-new-internal locale-new)
  67. (define locale-set-lang-internal! locale-set-lang!)
  68. (define locale-set-territory-internal! locale-set-territory!)
  69.  
  70. ;; Create a locale object from a localestr. localestr assumes
  71. ;; following format. modifier is not supported
  72. ;;
  73. ;;   language[_territory][.codeset]
  74. ;;
  75. ;; Some exception rules exist.
  76. ;;
  77. ;; * Accept #f, "C" and "POSIX" as "en" locale
  78. ;;
  79. ;; * Accept "" as native locale as like as performed in
  80. ;;   setlocale(). It attempt to retrieve the locale information from
  81. ;;   LC_ALL and LANG environment variable. If failed to retrieve the
  82. ;;   information from the two variable, it defaults to "en". It does
  83. ;;   not attempt to retrieve from particular locale category such as
  84. ;;   LC_CTYPE or LC_MESSAGES since appropriate category for input
  85. ;;   method does not exist
  86. (define locale-new
  87.   (lambda (localestr)
  88.     (let* ((substituted-str (cond
  89.                  ((not (string? localestr))    ;; mainly for #f
  90.                   "C")
  91.                  ((string=? localestr "")
  92.                   (or (getenv "LC_ALL")
  93.                   (getenv "LANG")
  94.                   "C"))
  95.                  (else
  96.                   localestr)))
  97.        (canonical-str (cond
  98.                ((or (string=? substituted-str "C")
  99.                 (string=? substituted-str "POSIX"))
  100.                 "en")
  101.                (else
  102.                 substituted-str)))
  103.        ;; detect delimiter with empty part such as "ja_", "_JP" or
  104.        ;; "ja."
  105.        (invalid-pair? (lambda (orig-str pair)
  106.                 (case (length pair)
  107.                   ((1) #f)
  108.                   ((2)
  109.                    (or (zero? (string-length (car pair)))
  110.                    (zero? (string-length (cadr pair)))))
  111.                   (else #t))))
  112.        (locale-split (lambda (locale delimiter)
  113.                (let* ((pair (string-split locale delimiter))
  114.                   (invalid? (invalid-pair? locale pair))
  115.                   (former (if (and (not invalid?)
  116.                            (not (null? pair)))
  117.                           (car pair)
  118.                           ""))
  119.                   (latter (if (and (not invalid?)
  120.                            (not (null? pair))
  121.                            (not (null? (cdr pair))))
  122.                           (cadr pair)
  123.                           "")))
  124.                  (cons former latter))))
  125.        (lang-territory (car (locale-split canonical-str ".")))
  126.        (codeset (cdr (locale-split canonical-str ".")))
  127.        (lang (car (locale-split lang-territory "_")))
  128.        (territory (cdr (locale-split lang-territory "_")))
  129.        (localeobj (locale-new-internal)))
  130.       ;; set attributes with validation
  131.       (locale-set-lang! localeobj lang)
  132.       (locale-set-territory! localeobj territory)
  133.       (locale-set-codeset! localeobj codeset)
  134.       ;; make whole part invalid if one of them is invalid
  135.       (if (and (not (string=? (locale-lang localeobj)
  136.                   ""))
  137.            (string=? (locale-territory localeobj)
  138.              territory)
  139.            (string=? (locale-codeset localeobj)
  140.              codeset))
  141.       localeobj
  142.       (locale-new-internal "")))))
  143.  
  144. (define locale-set-lang!
  145.   (lambda (locale lang)
  146.     (let ((validated-lang (or (and (string? lang)
  147.                    (= (string-length lang)
  148.                       2)
  149.                    lang)
  150.                   "")))
  151.       (locale-set-lang-internal! locale validated-lang))))
  152.  
  153. (define locale-set-territory!
  154.   (lambda (locale territory)
  155.     (let ((validated-territory (or (and (string? territory)
  156.                     (= (string-length territory)
  157.                        2)
  158.                     territory)
  159.                    "")))
  160.       (locale-set-territory-internal! locale validated-territory))))
  161.  
  162. (define locale-lang-territory-str
  163.   (lambda (locale)
  164.     (let ((lang (locale-lang locale))
  165.       (territory (locale-territory locale)))
  166.       (if (and (= (string-length lang)
  167.           2)
  168.            (= (string-length territory)
  169.           2))
  170.       (string-append lang "_" territory)
  171.       lang))))
  172.  
  173. (define locale-str
  174.   (lambda (locale)
  175.     (let ((lang-territory (locale-lang-territory-str locale))
  176.       (codeset (locale-codeset locale)))
  177.       (if (and (<= 2
  178.            (string-length lang-territory))
  179.            (< 0
  180.           (string-length codeset)))
  181.       (string-append lang-territory "." codeset)
  182.       lang-territory))))
  183.  
  184. (define locale-zh-awared-lang
  185.   (lambda (locale)
  186.     (if (string=? (locale-lang locale)
  187.           "zh")
  188.     (locale-lang-territory-str locale)
  189.     (locale-lang locale))))
  190.  
  191. ;;
  192. ;; language handling
  193. ;;
  194.  
  195. ;; requires 'N_' definition
  196. (require "iso-639-1.scm")
  197.  
  198. ;; This predicate supports following langgrp formats
  199. ;;
  200. ;; "ja"          matches with the language exactly
  201. ;; "en:fr:de"    matches with one of the colon-separated language
  202. ;; "zh_TW:zh_HK" matches with one of the colon-separated lang-territory string
  203. ;; "*"           matches with any languages
  204. ;; ""            matches with no languages
  205. (define langgroup-covers?
  206.   (lambda (langgrp lang)
  207.     (cond
  208.      ((or (not (string? langgrp))
  209.       (not (string? lang))
  210.       (string=? langgrp ""))
  211.       #f)
  212.      ((string=? langgrp "*")
  213.       #t)
  214.      (else
  215.       (let ((langs (string-split langgrp ":")))
  216.     (member lang langs))))))
  217.  
  218. (define lang-code->lang-name
  219.   (lambda (langcode)
  220.     (let* ((pair (assoc langcode iso-639-1-alist))
  221.        (langname (and pair
  222.               (cdr pair))))
  223.       (or langname
  224.       "-"))))
  225.  
  226. (define lang-name->lang-code
  227.   (lambda (langname)
  228.     (or (find (lambda (pair)
  229.                 (and (string=? (cdr pair)
  230.                                langname)
  231.                      (car pair)))
  232.               iso-639-1-alist)
  233.         "-")))
  234.  
  235. ;; returns "zh_TW" of "zh_TW:zh_HK"
  236. (define langgroup-primary-lang-code
  237.   (lambda (localestr)
  238.     (let* ((primary-localestr (if (not (string=? localestr ""))
  239.                   (car (string-split localestr ":"))
  240.                   "invalid"))  ;; intentionally invalid
  241.        (locale (locale-new primary-localestr))
  242.        (langcode (locale-zh-awared-lang locale)))
  243.       langcode)))
  244.